#lang racket

(require syntax/strip-context)
(require parser-tools/lex)
(require (prefix-in : parser-tools/lex-sre))
(require parser-tools/yacc)

(define helang-syntax #'(module anything racket
(define (+print array)
    (displayln (string-join (map number->string (vector->list array)) " | ")))

(define (sprint array)
    (displayln (list->string (map integer->char (vector->list array)))))

(define (array-ref array indexes)
    (vector-map (compose (curry vector-ref array) sub1) indexes))

(define (array-set! array indexes value)
    (let ([value (vector-ref value 0)])
    (if (zero? (vector-ref indexes 0))
        (vector-fill! array value)
    (for ([i indexes])
        (vector-set! array (sub1 i) value)))))

(define (make-array length)
    (make-vector (vector-ref length 0) 0))

(define (increment array)
    (for ([i (vector-length array)])
        (vector-set! array i (add1 (vector-ref array i)))))

(define (mul left right)
    (let (
        [length-left (vector-length left)]
        [length-right (vector-length right)])
    (do (
        [i 0 (add1 i)]
        [acc 0 (+ acc (* (vector-ref left i) (vector-ref right i)))])
        ((or (= i length-left) (= i length-right))
            (vector acc)))))

(define (add left right)
    (let (
        [length-left (vector-length left)]
        [length-right (vector-length right)])
    (cond
    [(= length-left 1)
        (vector-map (curry + (vector-ref left 0)) right)]
    [(= length-right 1)
        (vector-map (curry + (vector-ref right 0)) left)]
    [(= length-left length-right)
        (vector-map + left right)])))

(define (sub left right)
    (let (
        [length-left (vector-length left)]
        [length-right (vector-length right)])
    (cond
    [(= length-right 1)
        (vector-map (lambda (i) (- i (vector-ref right 0))) left)]
    [(= length-left length-right)
        (vector-map - left right)])))

(define (cyberspaces)
    (displayln "// Getting your location...
// Your location is UNITED STATES.
// Congratulations! You are in the Cyber Spaces!"))))

(define-tokens basic-tokens (
    NUM
    ID
))

(define-empty-tokens punct-tokens (
    LBRACKET
    RBRACKET
    BITWISE-OR
    SEMICOLON
    EQ
    DOUBLE-ADD
    ADD
    SUB
    MUL
    U8
    PRINT
    SPRINT
    EXIT
    CYBERSPACES
    EOF
))

(define (id->reserved id)
    (case id
    [("u8") (token-U8)]
    [("print") (token-PRINT)]
    [("sprint") (token-SPRINT)]
    [("exit") (token-EXIT)]
    [("cyberspaces") (token-CYBERSPACES)]
    [else (token-ID (string->symbol id))]))

(define helang-lexer (lexer
    [(eof) (token-EOF)]
    ["[" (token-LBRACKET)]
    ["]" (token-RBRACKET)]
    ["|" (token-BITWISE-OR)]
    [";" (token-SEMICOLON)]
    ["=" (token-EQ)]
    ["++" (token-DOUBLE-ADD)]
    ["+" (token-ADD)]
    ["-" (token-SUB)]
    ["*" (token-MUL)]
    [(:+ numeric) (token-NUM (string->number lexeme))]
    [(:: "//" (:* (:~ #\newline))) (helang-lexer input-port)]
    [(:: (:or alphabetic #\_)
        (:* (:or alphabetic numeric #\_)))
        (id->reserved lexeme)]
    [whitespace (helang-lexer input-port)]))

(define helang-parser (parser
    [start +module]
    [end EOF]
    [error (curry printf "~a ~a ~a\n")]
    [tokens basic-tokens punct-tokens]
    [grammar
        [+module
            [(stmt SEMICOLON) (list $1)]
            [(stmt SEMICOLON +module) (cons $1 $3)]]
        [stmt
            [(CYBERSPACES) (list 'cyberspaces)]
            [(EXIT) (list 'exit)]
            [(expr) $1]
            [(PRINT expr) (list '+print $2)]
            [(SPRINT expr) (list 'sprint $2)]
            [(U8 ID EQ expr) (list 'define $2 $4)]
            [(U8 ID) (list 'define $2 (vector 0))]
            [(ID EQ expr) (list 'set! $1 $3)]
            [(ID DOUBLE-ADD) (list 'increment $1)]
            [(factor LBRACKET expr RBRACKET EQ expr)
                (list 'array-set! $1 $3 $6)]]
        [expr
            [(term) $1]
            [(expr ADD term) (list 'add $1 $3)]
            [(expr SUB term) (list 'sub $1 $3)]]
        [term
            [(factor) $1]
            [(factor MUL factor) (list 'mul $1 $3)]]
        [factor
            [(ID) $1]
            [(array) (cons 'vector $1)]
            [(LBRACKET expr RBRACKET) (list 'make-array $2)]
            [(factor LBRACKET expr RBRACKET) (list 'array-ref $1 $3)]]
        [array
            [(NUM) (list $1)]
            [(NUM BITWISE-OR array) (cons $1 $3)]]]))

(provide (rename-out 
    [helang-read read]
    [helang-read-syntax read-syntax]))

(define (helang-read in)
    (syntax->datum (helang-read-syntax #f in)))

; (define (helang-read-syntax src in)
;     (pretty-print (append
;         (syntax->datum helang-syntax)
;         (helang-parser (lambda () (helang-lexer in))))))

(define (helang-read-syntax src in)
    (strip-context
        (datum->syntax #f (append
            (syntax->datum helang-syntax)
            (helang-parser (lambda () (helang-lexer in)))))))
            